home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / pcl-src.zoo / lucid-low.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1992-07-09  |  12.4 KB  |  375 lines

  1. ;;; -*- Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;; 
  27. ;;; This is the Lucid lisp version of the file portable-low.
  28. ;;;
  29. ;;; Lucid:               (415)329-8400
  30. ;;; 
  31.  
  32. (in-package 'pcl)
  33.  
  34. ;;; First, import some necessary "internal" or Lucid-specific symbols
  35.  
  36. (eval-when (eval compile load)
  37.  
  38. (#-LCL3.0 progn #+LCL3.0 lcl:handler-bind 
  39.     #+LCL3.0 ((lcl:warning #'(lambda (condition)
  40.                    (declare (ignore condition))
  41.                    (lcl:muffle-warning))))
  42. (let ((importer
  43.         #+LCL3.0 #'sys:import-from-lucid-pkg
  44.     #-LCL3.0 (let ((x (find-symbol "IMPORT-FROM-LUCID-PKG" "LUCID")))
  45.            (if (and x (fboundp x))
  46.                (symbol-function x)
  47.                ;; Only the #'(lambda (x) ...) below is really needed, 
  48.                ;;  but when available, the "internal" function 
  49.                ;;  'import-from-lucid-pkg' provides better checking.
  50.                #'(lambda (name)
  51.                (import (intern name "LUCID")))))))
  52.   ;;
  53.   ;; We need the following "internal", undocumented Lucid goodies:
  54.   (mapc importer '("%POINTER" "DEFSTRUCT-SIMPLE-PREDICATE"
  55.            #-LCL3.0 "LOGAND&" "%LOGAND&" #+VAX "LOGAND&-VARIABLE"))
  56.  
  57.   ;;
  58.   ;; For without-interrupts.
  59.   ;; 
  60.   #+LCL3.0
  61.   (mapc importer '("*SCHEDULER-WAKEUP*" "MAYBE-CALL-SCHEDULER"))
  62.  
  63.   ;;
  64.   ;; We import the following symbols, because in 2.1 Lisps they have to be
  65.   ;;  accessed as SYS:<foo>, whereas in 3.0 lisps, they are homed in the
  66.   ;;  LUCID-COMMON-LISP package.
  67.   (mapc importer '("ARGLIST" "NAMED-LAMBDA" "*PRINT-STRUCTURE*"))
  68.   ;;
  69.   ;; We import the following symbols, because in 2.1 Lisps they have to be
  70.   ;;  accessed as LUCID::<foo>, whereas in 3.0 lisps, they have to be
  71.   ;;  accessed as SYS:<foo>
  72.   (mapc importer '(
  73.            "NEW-STRUCTURE"       "STRUCTURE-REF"
  74.            "STRUCTUREP"         "STRUCTURE-TYPE"  "STRUCTURE-LENGTH"
  75.            "PROCEDUREP"         "PROCEDURE-SYMBOL"
  76.            "PROCEDURE-REF"     "SET-PROCEDURE-REF" 
  77.            ))
  78. ; ;;
  79. ; ;;  The following is for the "patch" to the general defstruct printer.
  80. ; (mapc importer '(
  81. ;                "OUTPUT-STRUCTURE"       "DEFSTRUCT-INFO"
  82. ;           "OUTPUT-TERSE-OBJECT"  "DEFAULT-STRUCTURE-PRINT" 
  83. ;           "STRUCTURE-TYPE"       "*PRINT-OUTPUT*"
  84. ;           ))
  85.   ;;
  86.   ;; The following is for a "patch" affecting compilation of %logand&.
  87.   ;; On APOLLO, Domain/CommonLISP 2.10 does not include %logand& whereas
  88.   ;; Domain/CommonLISP 2.20 does; Domain/CommonLISP 2.20 includes :DOMAIN/OS
  89.   ;; on *FEATURES*, so this conditionalizes correctly for APOLLO.
  90.   #-(or (and APOLLO DOMAIN/OS) LCL3.0 VAX) 
  91.   (mapc importer '("COPY-STRUCTURE"  "GET-FDESC"  "SET-FDESC"))
  92.   
  93.   nil))
  94.  
  95. ;; end of eval-when
  96.  
  97. )
  98.     
  99.  
  100. ;;;
  101. ;;; Patch up for the fact that the PCL package creation in defsys.lisp
  102. ;;;  will probably have an explicit :use list ??
  103. ;;;
  104. ;;;  #+LCL3.0 (use-package *default-make-package-use-list*)
  105.  
  106.  
  107.  
  108.  
  109. #+lcl4.0
  110. (progn
  111.  
  112. (defvar *saved-compilation-speed* 3)
  113.  
  114. ; the production compiler sometimes
  115. ; screws up vars within labels
  116.  
  117. (defmacro dont-use-production-compiler ()
  118.   '(eval-when (compile)
  119.      (setq *saved-compilation-speed* (if LUCID:*USE-SFC* 3 0))
  120.      (proclaim '(optimize (compilation-speed 3)))))
  121.  
  122. (defmacro use-previous-compiler ()
  123.   `(eval-when (compile)
  124.      (proclaim '(optimize (compilation-speed ,*saved-compilation-speed*)))))
  125.  
  126. )
  127.  
  128. (defmacro %logand (x y)
  129.   #-VAX `(%logand& ,x ,y)
  130.   #+VAX `(logand&-variable ,x ,y))
  131.  
  132. ;;; Fix for VAX LCL
  133. #+VAX
  134. (defun logand&-variable (x y)
  135.   (logand&-variable x y))
  136.  
  137. ;;; Fix for other LCLs
  138. #-(or (and APOLLO DOMAIN/OS) LCL3.0 VAX)
  139. (eval-when (compile load eval)
  140.  
  141. (let* ((logand&-fdesc (get-fdesc 'logand&))
  142.        (%logand&-fdesc (copy-structure logand&-fdesc)))
  143.   (setf (structure-ref %logand&-fdesc 0 t) '%logand&)
  144.   (setf (structure-ref %logand&-fdesc 7 t) nil)
  145.   (setf (structure-ref %logand&-fdesc 8 t) nil)
  146.   (set-fdesc '%logand& %logand&-fdesc))
  147.  
  148. (eval-when (load)
  149.   (defun %logand& (x y) (%logand& x y)))
  150.  
  151. (eval-when (eval)
  152.   (compile '%logand& '(lambda (x y) (%logand& x y))))
  153.  
  154. );#-(or LCL3.0 (and APOLLO DOMAIN/OS) VAX)
  155.  
  156. ;;;
  157. ;;; From: JonL
  158. ;;; Date: November 28th, 1988
  159. ;;; 
  160. ;;;  Here's a better attempt to do the without-interrupts macro for LCL3.0.
  161. ;;;  For the 2.1  release, maybe you should just ignore it (i.e, turn it 
  162. ;;;  into a PROGN and "take your chances") since there isn't a uniform way
  163. ;;;  to do inhibition.  2.1 has interrupts, but no multiprocessing.
  164. ;;;
  165. ;;;  The best bet for protecting the cache is merely to inhibit the
  166. ;;;  scheduler, since asynchronous interrupts are only run when "scheduled".
  167. ;;;  Of course, there may be other interrupts, which can cons and which 
  168. ;;;  could cause a GC; but at least they wouldn't be running PCL type code.
  169. ;;;
  170. ;;;  Note that INTERRUPTS-ON shouldn't arbitrarily enable scheduling again,
  171. ;;;  but rather simply restore it to the state outside the scope of the call
  172. ;;;  to WITHOUT-INTERRUPTS.  Note also that an explicit call to 
  173. ;;;  MAYBE-CALL-SHEDULER must be done when "turning interrupts back on", if
  174. ;;;  there are any interrupts/schedulings pending; at least the test to see
  175. ;;;  if any are pending is very fast.
  176.  
  177. #+LCL3.0
  178. (defmacro without-interrupts (&body body)
  179.   `(macrolet ((interrupts-on  ()
  180.         `(when (null outer-scheduling-state)
  181.            (setq lcl:*inhibit-scheduling* nil)
  182.            (when *scheduler-wakeup* (maybe-call-scheduler))))
  183.           (interrupts-off () 
  184.         '(setq lcl:*inhibit-scheduling* t)))
  185.      (let ((outer-scheduling-state lcl:*inhibit-scheduling*))
  186.        (prog1 (let ((lcl:*inhibit-scheduling* t)) . ,body)
  187.           (when (and (null outer-scheduling-state) *scheduler-wakeup*)
  188.         (maybe-call-scheduler))))))
  189.  
  190.  
  191. ;;; The following should override the definitions provided by lucid-low.
  192. ;;;
  193. #+(or LCL3.0 (and APOLLO DOMAIN/OS))
  194. (defstruct-simple-predicate  std-instance std-instance-p)
  195.  
  196.  
  197. (defun set-function-name-1 (fn new-name ignore)
  198.   (declare (ignore ignore))
  199.   (if (not (procedurep fn))
  200.       (error "~S is not a procedure." fn)
  201.       (if (compiled-function-p fn)
  202.       ;; This is one of:
  203.       ;;   compiled-function, funcallable-instance, compiled-closure
  204.       ;;   or a macro.
  205.       ;; So just go ahead and set its name.
  206.       ;; Only change the name when necessary: maybe it is read-only.
  207.       (unless (eq new-name (procedure-ref fn procedure-symbol))
  208.         (set-procedure-ref fn procedure-symbol new-name))
  209.       ;; This is an interpreted function.
  210.       ;; Seems like any number of different things can happen depending
  211.       ;; vaguely on what release you are running.  Try to do something
  212.       ;; reasonable.
  213.       (let ((symbol (procedure-ref fn procedure-symbol)))
  214.         (cond ((symbolp symbol)
  215.            ;; In fact, this is the name of the procedure.
  216.            ;; Just set it.
  217.            (set-procedure-ref fn procedure-symbol new-name))
  218.           ((and (listp symbol)
  219.             (eq (car symbol) 'lambda))
  220.            (setf (car symbol) 'named-lambda
  221.              (cdr symbol) (cons new-name (cdr symbol))))
  222.           ((eq (car symbol) 'named-lambda)
  223.            (setf (cadr symbol) new-name))))))          
  224.   fn)
  225.  
  226. (defun function-arglist (fn)
  227.   (arglist fn))
  228.  
  229.   ;;   
  230. ;;;;;; printing-random-thing-internal
  231.   ;;
  232. (defun printing-random-thing-internal (thing stream)
  233.   (format stream "~O" (%pointer thing)))
  234.  
  235.  
  236. ;;;
  237. ;;; 16-Feb-90 Jon L White
  238. ;;;
  239. ;;; A Patch provide specifically for the benefit of PCL, in the Lucid 3.0
  240. ;;;  release environment.  This adds type optimizers for FUNCALL so that
  241. ;;;  forms such as:
  242. ;;;
  243. ;;;     (FUNCALL (THE PROCEDURE F) ...)
  244. ;;;
  245. ;;;  and:
  246. ;;;
  247. ;;;     (LET ((F (Frobulate)))
  248. ;;;       (DECLARE (TYPE COMPILED-FUNCTION F))
  249. ;;;       (FUNCALL F ...))
  250. ;;;
  251. ;;;  will just jump directly to the procedure code, rather than waste time
  252. ;;;  trying to coerce the functional argument into a procedure.
  253. ;;;
  254.  
  255.  
  256. (in-package "LUCID")
  257.  
  258.  
  259. ;;; (DECLARE-MACHINE-CLASS COMMON)
  260. (set-up-compiler-target 'common)
  261.  
  262.  
  263. (set-function-descriptor 'FUNCALL
  264.   :TYPE  'LISP
  265.   :PREDS 'NIL
  266.   :EFFECTS 'T
  267.   :OPTIMIZER  #'(lambda (form &optional environment) 
  268.           (declare (ignore form environment))
  269.           (let* ((fun (second form))
  270.              (lambdap (and (consp fun) 
  271.                        (eq (car fun) 'function)
  272.                        (consp (second fun))
  273.                        (memq (car (second fun))
  274.                          '(lambda internal-lambda)))))
  275.             (if (not lambdap) 
  276.             form
  277.             (alphatize 
  278.               (cons (second fun) (cddr form)) environment))))
  279.   :FUNCTIONTYPE '(function (function &rest t) (values &rest t))
  280.   :TYPE-DISPATCH `(((PROCEDURE &REST T) (VALUES &REST T)
  281.             ,#'(lambda (anode fun &rest args) 
  282.              (declare (ignore anode fun args))
  283.              `(FAST-FUNCALL ,fun ,@args)))
  284.            ((COMPILED-FUNCTION &REST T)  (VALUES &REST T)
  285.             ,#'(lambda (anode fun &rest args) 
  286.              (declare (ignore anode fun args))
  287.              `(FAST-FUNCALL ,fun ,@args))))
  288.   :LAMBDALIST '(FN &REST ARGUMENTS)
  289.   :ARGS '(1 NIL)
  290.   :VALUES '(0 NIL)
  291.   )
  292.  
  293. (def-compiler-macro fast-funcall (&rest args &environment env)
  294.   (if (COMPILER-OPTION-SET-P :READ-SAFETY ENV)
  295.       `(FUNCALL-SUBR . ,args)
  296.       `(&FUNCALL . ,args)))
  297.  
  298.  
  299.  
  300. (setf (symbol-function 'funcall-subr) #'funcall)
  301.  
  302.  
  303. ;;; (UNDECLARE-MACHINE-CLASS)
  304. (restore-compiler-params)
  305.  
  306.  
  307. (in-package 'pcl)
  308.  
  309. (pushnew :structure-wrapper *features*)
  310. (pushnew :structure-functions *features*)
  311.  
  312. (defvar *structure-type* nil)
  313. (defvar *structure-length* nil)
  314.  
  315. (defun known-structure-type-p (type)
  316.   (declare (special lucid::*defstructs*))
  317.   (let ((s-data (gethash type lucid::*defstructs*)))
  318.     (or (and s-data 
  319.          (eq 'structure (structure-ref s-data 1 'defstruct))) ; type - Fix this
  320.     (and type (eq *structure-type* type)))))
  321.  
  322. (defun structure-type-included-type-name (type)
  323.   (declare (special lucid::*defstructs*))
  324.   (let ((s-data (gethash type lucid::*defstructs*)))
  325.     (and s-data (structure-ref s-data 6 'defstruct)))) ; include - Fix this
  326.  
  327. (defun structure-type-slot-description-list (type)
  328.   (declare (special lucid::*defstructs*))
  329.   (let ((s-data (gethash type lucid::*defstructs*)))
  330.     (if s-data
  331.     (nthcdr (the index
  332.                      (let ((include (structure-ref s-data 6 'defstruct)))
  333.                (if include
  334.                    (let ((inc-s-data (gethash include lucid::*defstructs*)))
  335.                       (if inc-s-data
  336.                      (length (structure-ref inc-s-data 7 'defstruct))
  337.                      0))
  338.                    0)))
  339.         (map
  340.                  'list
  341.          #'(lambda (slotd)
  342.              (let* ((slot-name (system:structure-ref slotd 0 'lucid::defstruct-slot))
  343.                 (position (system:structure-ref slotd 1 'lucid::defstruct-slot))
  344.                 (accessor (system:structure-ref slotd 2 'lucid::defstruct-slot))
  345.                 (read-only-p (system:structure-ref slotd 5 'lucid::defstruct-slot)))
  346.                (list slot-name accessor
  347.                  #'(lambda (x)
  348.                      (system:structure-ref x position type))
  349.                  (unless read-only-p
  350.                    #'(lambda (v x)
  351.                        (setf (system:structure-ref x position type)
  352.                          v))))))
  353.          (structure-ref s-data 7 'defstruct))) ; slots  - Fix this
  354.     (let ((result (make-list (the index *structure-length*))))
  355.       (dotimes (i *structure-length* result)
  356.         (let* ((name (format nil "SLOT~D" i))
  357.            (slot-name (intern name (or (symbol-package type) *package*)))
  358.            (i i))
  359.           (setf (elt result i) (list slot-name nil
  360.                      #'(lambda (x)
  361.                          (system:structure-ref x i type))
  362.                      nil))))))))
  363.  
  364. (defun structure-slotd-name (slotd)
  365.   (first slotd))
  366.  
  367. (defun structure-slotd-accessor-symbol (slotd)
  368.   (second slotd))
  369.  
  370. (defun structure-slotd-reader-function (slotd)
  371.   (third slotd))
  372.  
  373. (defun structure-slotd-writer-function (slotd)
  374.   (fourth slotd))
  375.